
package Sgdb::DataTracepoints ;

use Sgdb::Utils qw (:DEFAULT
                    ) ;



# pragmas for all
use warnings ;
use strict ;
use integer ;
use bytes ;

my $traces_recovery ;
my $clipboard = 'collect $regs, $locals, $args' ;
my $action_prompt = qr/Action|Stepping|^\s*\>/m ;

init() ;


sub init {

    hook_add ( 'recover-tracepoints' => \&traces_recovery,
               'recover-tracepoints-save-to-file' => \&traces_recovery_save_to_file,
               'tracepoints-clipboard' => \&tracepoints_clipboard,
               ) ;

    1 ;
}

sub new {

    my $self = shift or die "whoami" ;
    my $topf = shift or die "top frame needed" ;

    my $text = ( pref ('tracepoints-win-show-scrollbars') ?
                 $topf -> Scrolled ( 'ROText', pref 'tracepoints-win-text' ) :
                 $topf ->             ROText ( pref 'tracepoints-win-text' ) ) ;

    pref_tags $text, 'tracepoints-win', qw/header trace actions invalid-msg/ ;
    $text -> menu() -> configure ( -postcommand => [\&popup_tracpoints_menu, $text], pref 'pop-menu' ) ;
    hook_add ('refresh-breakpoints' => [\&refresh_breakpoints, $text] ,
              'new-symbol-file'     => [\&new_symbol_file,     $text] ,
              'invalid-symbol-file' => [\&invalid_symbol_file, $text] ,
              );

    pref_reconfigure  'tracepoints-win-text' => $text  ;

    # return:
    # 1. unpacked text object
    # 2. update command
    ( $text,
      sub { refresh_breakpoints( $text, @_ ) }
    ) ;
}

sub top_menu_recover_tracepoints {

    my $m = shift ;
    my $type = 'by-line' ;
    menu_fill ($m, 'top-menu',
               'Recovery',
               [['radiobutton',
                 -label => 'by abs address',
                 -value => 'by-addr' ,
                 -variable => \$type,
                ]],
               [['radiobutton',
                 -label => 'by source line',
                 -value => 'by-line',
                 -variable => \$type
                 ]],
               '-',
               [ 'Recover last session', [\&hook_run_lock, 'recover-tracepoints', \$type]],
               [ 'Recovery from file', [\&hook_run, 'recover-tracepoints', \$type, '']],
               '-',
               [ 'Save traces in file', [\&hook_run, 'recover-tracepoints-save-to-file']],
               ) ;
}

sub popup_tracpoints_menu {

    my $t = shift ;

    my $m = $t -> menu () ;
    $m -> delete ( 0 => 'end' ) ;

    my $sm ;
    # my @pref_menu_pop = pref 'pop-menu' ;

    my $current  = $t -> index   ( 'current' ) ;

    my ( $num, $enable, $addr, $file, $line ) ;

    while ( ! $num ) {

        my $trace = $t -> get ( "$current linestart" => "$current lineend" ) ;

        if    ( $trace =~ /^(\d+)\s+([yn])\s+(0x[\da-f]+)\s+.*at\s+(\S+):(\d+)/ ) {

            ($num, $enable, $addr, $file, $line) = ($1, $2, $3, $4, $5) ;
        }
        elsif ( $trace =~ /^(\d+)\s+([yn])\s+(0x[\da-f]+)/ ) {

            ($num, $enable, $addr ) = ($1, $2, $3) ;
        }
        elsif ( $t -> compare ( $current, '<', "2.0" ) ) {

            undef $current ;
            last ;
        }
        else {

            $current = $t -> index ( "$current -1 line" ) ;
        }
    }

    # if ( $current ) {

    my $anti_enable = ($enable eq 'y') ? 'disable' : 'enable ' ;
    my $show_actions = $t -> tagCget( 'actions', '-elide' ) ;
    my $selexists = $t -> tagRanges( 'sel' ) ;

        # $sm = $m -> Menu ( -tearoff => 0, @pref_menu_pop ) ;

        # $m -> add ( 'cascade',
        #             -label => 'Query',
        #             -menu => $sm
        #           ) ;

    menu_fill ( $m, 'pop-menu',
                (iff $current,
                 ["info line *$addr", [\&gdb_exec_lock, "info line *$addr"]],
                 '-',
                 [ "tfind tr $num", [\&gdb_exec_lock, "tfind tracepoint $num"]],
                 [ "tstatus  $num", [\&gdb_exec_lock, "tstatus $num"]],
                 '-',
                 [ "tstatus all", [\&gdb_exec_lock, "tstatus" ]],
                 'Edit',
                 [ "Edit Actions $num", [\&hook_run_lock, 'set-tracepoint-action', $num]],
                 [ "Copy $num To Clipboard", [\&runlocked, \&dominate_action, $t, $num, 'copy' ]],
                 [ "Paste To $num" , [\&runlocked, \&dominate_action, $t, $num, 'paste'],
                   -state => $clipboard ? 'normal' : 'disabled' ],
                 [ 'Paste To All', [\&runlocked, \&dominate_action, $t, $num, 'all' ],
                   -state => $clipboard ? 'normal' : 'disabled'],
                 [ 'Paste To Empty', [\&runlocked, \&dominate_action, $t, $num, 'empty'],
                   -state => $clipboard ? 'normal' : 'disabled' ],
                 [ 'Paste To Exist', [\&runlocked, \&dominate_action, $t, $num, 'exist'],
                   -state => $clipboard ? 'normal' : 'disabled' ],
                 '-',
                 [ 'Dump Clipboard', [\&telthem, $clipboard],
                   -state => $clipboard ? 'normal' : 'disabled'],
                 '-',
                 [[checkbutton => -label => 'Hide Actions',
                   -variable => \$show_actions,
                   -command => sub { $t -> tagConfigure ( 'actions',
                                                          pref ( 'tracepoints-win-actions-tag' ) ,
                                                          -elide => $show_actions ) }]],
                 'Handle',
                 [ "delete  tracepoint $num", [\&gdb_exec_lock, "delete tracepoint $num"]],
                 [ "delete all", [\&gdb_exec_lock, "delete tracepoints"]],
                 [ 'delete  selection', [\&action_selection, $t, 'delete tracepoint' ],
                   -state   => $selexists ? 'normal' : 'disabled'],
                 '-',
                 [ "$anti_enable tracepoint $num", [\&gdb_exec_lock, "$anti_enable tracepoint $num"]],
                 [ 'disable selection', [\&action_selection, $t, 'disable tracepoint' ],
                   -state   => $selexists ? 'normal' : 'disabled'],
                 [ 'enable  selection', [\&action_selection, $t, 'enable tracepoint' ],
                   -state   => $selexists ? 'normal' : 'disabled'],
                 '-',
                ),
                'Recover',
                [ 'last session :by Address', [\&hook_run_lock, 'recover-tracepoints', 'by-addr']],
                [ 'from file    :by Address', [\&hook_run, 'recover-tracepoints', 'by-addr', '']],
                [ 'last session :by Line', [\&hook_run_lock, 'recover-tracepoints', 'by-line']],
                [ 'from file    :by Line', [\&hook_run, 'recover-tracepoints', 'by-line', '']],
                '-',
                [ 'Save traces in file', [\&hook_run, 'recover-tracepoints-save-to-file']],
                '-',
                [ 'Close', [\&hook_run, 'close-current-data-pane' ]],
              )
}

sub action_selection {

    my ($t, $cmd ) = @_ ;

    my ($first, $last ) = $t -> tagRanges ( 'sel' ) ;

    for ( my $cur = $t -> index ( "$first linestart" )  ;
          $t -> compare ( $cur, '<', $last )            ;
          $cur = $t -> index ( "$cur +1 line" )         ) {

        $t -> get ( "$cur linestart", "$cur lineend" ) =~
            /^(\d+)\s+[yn]\s+0x[\da-f]+/
                or next ;

        my $num = $1 ;

        gdb_exec_quiet "$cmd $num" ;
    }

    hook_run 'refresh-breakpoints' ;
}

sub ex_tracepoints_list {

    my $file = shift || '.' ;
    my $tp ;

    if ( $file =~ s/\*?0x//  ) {

        return unless defined ($tp = gdb_exec_quiet( 'info tracepoints' )) ;
        return grep /^\d+\s+[yn]\s+0x0*$file/, split /\n/, $tp ;
    }
    else {

        $file =~ s/\.\.\/// ;
        return unless defined ($tp = gdb_exec_quiet( 'info tracepoints' )) ;
        return grep /^\d+\s+[yn]\s+0x[a-f\d]+.*[ \/]\Q$file\E/, split /\n/, $tp ;
    }

# returns strings like
#  "# 1   y   0x003691e4 6     0     in exec_98_util at ../98_util.c:361"
}

sub refresh_breakpoints {

    my $t = shift ;
    return telme 'no text' unless istkwidget $t ;

    my $tp = gdb_exec_quiet ( 'info tracepoints' ) or return ;

    $traces_recovery = $tp if $tp and $tp !~ /no tracepoints/gi ;

    my @tp ;

    foreach my $line ( split /^/, $tp ) {


        push
            @tp,
            $line,
            ( ( $line =~ /^Num Enb/ ) ? 'header'  :
              ( $line =~ /^\d/      ) ? 'trace'   :
                                        'actions'
              );
    }

    $t -> delete    ( '1.0'  => 'end'      ) ;
    $t -> insert    ( 'end'  => @tp        ) ;
}

sub dominate_action {

    my ($t, $num, $type) = @_ ;

    my @tp = split /^(?=\d+\s+[yn])/m, $t -> get( '1.0' => 'end' ) ;

    my ( @todo, $actions ) ;

    if    ( $type eq 'copy' ) {

        foreach my $tp ( @tp ) {
            my ($n) = $tp =~ /^(\d+)\s+[ny]/ or next ;
            if ( $n == $num ) {

                ( $actions ) = $tp =~ /Actions for tracepoint \d+\s*:\s*(.*?)\s*$/s ;
                return telthemloud "can't locate actions for tp $num" unless $actions ;
                return $clipboard = $actions ;
            }
        }
        return telthemloud "can't locate tp $num" ;
    }
    elsif ( $type eq 'paste' ) {

        $actions = $clipboard ;
        @todo = $num ;
    }
    else {

        $actions = $clipboard ;

        foreach my $tp ( @tp ) {

            my ($n) = $tp =~ /^(\d+)\s+[ny]/ or next ;

#              if     ( $n == $num ) {

#                  ( $actions ) = $tp =~ /Actions for tracepoint \d+\s*:(.*)$/s ;

#                  $actions =~ s/^\s+// ;
#                  $actions or last ;
#              }
#              elsif
            if ( $tp =~ /Actions for tracepoint \d+/ ) {

                push @todo, $n unless $type eq 'empty' ;
            }
            else {

                push @todo, $n unless $type eq 'exist' ;
            }
        }
    }

    if ( $actions ) {

        my @actions = split /^/, $actions ;
        chomp @actions ;
        push @actions, ('end') x 3 ;

        foreach my $n ( @todo ) {

            my ($res, $err, $prompt) =  gdb_exec_quiet "actions $n" ;

            foreach my $act ( @actions ) {

                return telthemloud $err if $err ;
                $prompt =~ $action_prompt or last ;
                gdb_exec_quiet $act ;
            }
        }
    }
    else {

        telthem "no actions for tp $num" ;
    }
    hook_run 'refresh-breakpoints' ;
}

sub new_symbol_file {

    my $t = shift ;

    return telme 'no text' unless istkwidget $t ;

    $t -> delete ('1.0' => '1.0 lineend' ) ;
    $t -> insert    ( '1.0',
                      "Beware: Those Traces are Probably Invalid" => 'invalid-msg'
                      ) ;
    $t -> see ( '1.0' ) ;
    telthem "you can use 'Traces->Recovery->recover last session' to recreate tracepoints" if $traces_recovery ;
}

sub invalid_symbol_file {

    my $t = shift ;
    return telme 'no text' unless istkwidget $t ;

    $t -> delete ('1.0' => '1.0 lineend' ) ;
    $t -> insert    ( '1.0',
                      "Beware: Those Traces are Probably Invalid" => 'invalid-msg'
                      ) ;
    $t -> see ( '1.0' ) ;
}

sub traces_recovery {

    gdb_cached 'is-alive' or return telthemloud 'how about activating?' ;

    my ($type, $file, $traces)  = @_ ;

    $type = $$type if ref $type eq 'SCALAR' ;
    $file = $$file if ref $type eq 'SCALAR' ;

    my $last ;

    if ( defined $file ) {

        $file ||= find_file ( 0, 'Open Tracepoints File',
                              pref 'last-tracepoints-file',
                              ) ;
        $file or return ;
        open FILE, $file or return telthemloud "can't open $file: $!" ;
        $traces = join '', <FILE> ;
        close FILE ;
        pref_set 'last-tracepoints-file', $file if $file ne pref 'last-tracepoints-file' ;
    }
    else {

        $traces = $traces_recovery ;
    }
    $traces or return telthemloud 'No traces to recover' ;

    busy ;

    foreach my $line (split /^/, $traces ) {

        if    ( $line =~ /^\s*Num/ ) {
        }
        elsif ( $line =~ /^\s*Actions/ ) {

            gdb_exec_quiet 'actions' ;
        }
        elsif ( $type eq 'by-addr' and
                $line =~ /([yn])       \s+
                          (0x[\da-f]+) \s+
                          (\d+)        /x
                ) {

            my ($enable, $addr, $passc ) = ($1, $2, $3) ;
            my $loc = gdb_exec_quiet ( "trace *$addr" ) ;
            my ($num) = $loc =~ /(\d+)/ ;
            gdb_exec_quiet "passcount $passc" if $passc ;
            gdb_exec_quiet "disable t $num" if $num and $enable eq 'n' ;

            # sanity check
            my ($old, $new) ;
            if ( ($old) = $line =~ /(\d+)\W*$/ and
                 ($new) = $loc  =~ /(\d+)\W*$/ and
                 $old != $new ) {
                telthemloud ( $num ?
                              "tracepoints recovery: tp number $num: wrong line" :
                              "tracepoints recovery: tp at $addr: wrong line"
                              ) ;
            }
        }
        elsif ( $type eq 'by-line' and
                $line =~ /([yn])         \s+
                           0x[\da-f]+    \s+
                           (\d+)         \s+
                           .+at          \s+
                           (.+?)         \s+$/x
                ) {

            my ($enable, $passc, $addr) = ($1, $2, $3) ;
            my ($num) = gdb_exec_quiet ( "trace $addr" ) =~ /(\d+)/ ;
            gdb_exec_quiet "passcount $passc" if $passc ;
            gdb_exec_quiet "disable t $num" if $num and $enable eq 'n' ;
        }
        else {

            $line =~ s/^\s+// ;
            $line =~ s/\s+$// ;
            gdb_exec_quiet $line ;
        }
    }
    gdb_exec_quiet 'end' ;
    hook_run 'show-data-tracepoints' ;
    hook_run 'refresh-breakpoints' ;
    unbusy ;
}

sub traces_recovery_save_to_file {

    return telthemloud "no tracepoints to save" unless $traces_recovery ;
#      my $file = shift || $mainwindow -> getSaveFile ( -title => 'Save Tracepoints To File',
#                                                       ) ;
    my $file = shift || find_file ( 1, 'Save Tracepoints To File',
                                    pref 'last-tracepoints-file',
                                    ) ;
    $file or return ;
    open  FILE, ">$file" or return telthemloud "can't write to $file: $!" ;
    print FILE $traces_recovery ;
    close FILE or return telthemloud "can't close $file: $!" ;

    pref_set 'last-tracepoints-file', $file if $file ne pref 'last-tracepoints-file' ;
    telthem "saved current traces to $file" ;
}

sub tracepoints_clipboard {
    my $type = shift ;

    if   ( $type eq 'cut' or
           $type eq 'copy' ) {

        my $num = shift or return telme "no num" ;
        my @tp = split /^(?=\d+\s+[yn])/m, scalar gdb_exec_quiet 'info tracepoints' ;

        foreach my $tp ( @tp ) {

            my ($n) = $tp =~ /^(\d+)\s+[ny]/ or next ;
            next unless $n == $num ;

            my ( $actions ) = $tp =~ /Actions for tracepoint \d+\s*:\s*(.*?)\s*$/s ;
            return telthemloud "can't locate actions for tp $num" unless $actions ;
            gdb_exec_quiet "d t $num" if $type eq 'cut' ;
            hook_run 'refresh-breakpoints' ;
            return $clipboard = $actions ;
        }
        return telthemloud "can't locate tp $num" ;
    }
    elsif ( $type eq 'paste' or 
            $type eq 'new' ) {

        return telthemloud 'Tracepoints Clipboard is Empty' unless $clipboard ;

        my    @actions = split /^/, $clipboard ;
        chomp @actions ;
        push  @actions , ('end') x 3 ;

        my $add = shift ;
        my ($res, $err, $prompt) ;

        if ( $type eq 'new' ) {
            ($res, $err, $prompt) = gdb_exec_quiet "trace $add" ;
            ($res, $err, $prompt) = gdb_exec_quiet "actions" ;
        }
        else {
            ($res, $err, $prompt) = gdb_exec_quiet "actions $add" ;
        }

        foreach my $act ( @actions ) {

           return telthemloud $err if $err ;
            $prompt =~ $action_prompt or last ;
            gdb_exec_quiet $act ;
        }
        return hook_run 'refresh-breakpoints' ;
    }
    else {
        return telme "bad type: $type" ;
    }
}
